home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / Bonus / Plasmatech / ptscp_eval.exe / %MAINDIR% / Examples / Demo / FMain.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2001-08-31  |  26.6 KB  |  845 lines
  1. unit FMain; // Copyright ⌐ 1996-2001 Plasmatech Software Design. All rights reserved.
  2. {
  3.  Shell Control Pack - Demo Program
  4.  Version 1.6
  5.  
  6.  This file is part of the Shell Control Pack demonstration program.
  7.  It implements the main tabbed form.
  8.  
  9.  History
  10.  ===================================================================================================
  11.  V1.6   2Jul01 Delphi 6 release. No changes.
  12.  V1.5c 30Mar01 No changes.
  13.  V1.5b 12Dec00 No changes.
  14.  V1.5a 14May00 No changes.
  15.  V1.5   3Mar00 C++Builder 5 release.
  16.  V1.4a  5Nov99 No changes.
  17.  V1.4  14Sep99 Delphi 5 release. No changes.
  18.  V1.3h 29Mar99 No changes.
  19.  V1.3g  1Dec98 No changes.
  20.  V1.3f 12Jul98 Delphi 4 release. No changes.
  21.  V1.3e 22Apr98 No changes.
  22.  V1.3d 18Apr98 No changes.
  23.  V1.3c 16Mar98 No changes.
  24.  V1.3b  7Feb98 No changes.
  25.  V1.3a  7Jan98 Added hints to toolbar image.
  26.  V1.3  28Nov97 Added internationalisation code.
  27.  V1.2b 12Oct97 No changes.
  28.  V1.2a  5Oct97 No significant changes.
  29.  V1.2   6Sep97 Added aCD.Canvas example to PTTreeView1CustomDraw method.
  30.  V1.1a  6Jul97 No changes.
  31.  V1.1  26Jun97 Added palette support for welcome page.
  32.                Added scrollboxes to the splitter demo.
  33.                Added Custom Draw Tree page.
  34.  V1.0c 31May97 No significant changes.
  35.  V1.0b 17May97 Minor fixes and Delphi 3 support.
  36.  V1.0a  1May97 No significant changes.
  37.  V1.0  21Apr97 Released version 1.0
  38. }
  39.  
  40. {$INCLUDE PTCompVer.inc}
  41.  
  42. {$RANGECHECKS OFF} {$OVERFLOWCHECKS OFF} {$WRITEABLECONST OFF}
  43. {$BOOLEVAL OFF}    {$EXTENDEDSYNTAX ON}  {$TYPEDADDRESS ON}
  44.  
  45. interface
  46. uses
  47.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  48.   StdCtrls, ComCtrls, ExtCtrls, Buttons, Ole2, Menus,
  49.     UPTSplitter, UPTShellControls, UPTShell95, UPTShellUtils, UPTImageCombo,
  50.     FPTOpenDlg, FPTFolderBrowseDlg, UPTTreeList, UPTFrame;
  51.  
  52.  
  53. type TMaxLogPalette = packed record
  54.        palVersion: Word;
  55.        palNumEntries: Word;
  56.        palPalEntry: array [Byte] of TPaletteEntry;
  57.      end;
  58.      PMaxLogPalette = ^TMaxLogPalette;
  59.  
  60. // Type used to store data with the tree on the "Custom Draw Tree" page.
  61. type TTvData = class
  62.        private
  63.          mFont: TFont;
  64.          mBkColor: TColor;
  65.          procedure SetFont( aValue: TFont );
  66.        public
  67.          constructor Create( aFont: TFont;  aColor: TColor );
  68.          destructor Destroy; override;
  69.          property Font: TFont read mFont write SetFont;
  70.          property BkColor: TColor read mBkColor write mBkColor;
  71.      end;
  72.  
  73. type
  74.   TFrmMain = class(TForm)
  75.     PageControl1: TPageControl;
  76.     ExplorerTsh: TTabSheet;
  77.     Button1: TButton;
  78.     SplitterTsh: TTabSheet;
  79.     PTSplitter3: TPTSplitter;
  80.     PTSplitter4: TPTSplitter;
  81.     Label2: TLabel;
  82.     PTSplitter5: TPTSplitter;
  83.     Label3: TLabel;
  84.     ListTsh: TTabSheet;
  85.     WelcomeTsh: TTabSheet;
  86.     PaintBox1: TPaintBox;
  87.     Label1: TLabel;
  88.     Label4: TLabel;
  89.     VersionTxt: TLabel;
  90.     Panel1: TPanel;
  91.     PlasmaLogoImg: TImage;
  92.     CopyrightLabel: TLabel;
  93.     Label7: TLabel;
  94.     Label8: TLabel;
  95.     Button3: TButton;
  96.     Button5: TButton;
  97.     Button6: TButton;
  98.     Button8: TButton;
  99.     Button9: TButton;
  100.     Label9: TLabel;
  101.     OpenDialogTsh: TTabSheet;
  102.     FolderBrowseTsh: TTabSheet;
  103.     OverviewTsh: TTabSheet;
  104.     Button7: TButton;
  105.     Button4: TButton;
  106.     Button11: TButton;
  107.     Button12: TButton;
  108.     Edit1: TEdit;
  109.     Label10: TLabel;
  110.     TestOpenDlgBtn: TButton;
  111.     Button14: TButton;
  112.     Button15: TButton;
  113.     Button16: TButton;
  114.     Button17: TButton;
  115.     Label11: TLabel;
  116.     PTShellList1: TPTShellList;
  117.     PTOpenDlg1: TPTOpenDlg;
  118.     OverviewRchtxt: TRichEdit;
  119.     ExplorerRchtxt: TRichEdit;
  120.     FileOpenRchedt: TRichEdit;
  121.     TabSheet8: TTabSheet;
  122.     UppercaseEdt: TEdit;
  123.     Label14: TLabel;
  124.     Label15: TLabel;
  125.     GetDisplayEdt: TEdit;
  126.     Button18: TButton;
  127.     Button19: TButton;
  128.     ShellGetDisplayPathnameRchedt: TRichEdit;
  129.     FolderBrowseRchedt: TRichEdit;
  130.     ToolbarImg: TImage;
  131.     PTFolderBrowseDlg1: TPTFolderBrowseDlg;
  132.     FolderBrowseBtn: TButton;
  133.     TabSheet4: TTabSheet;
  134.     ImageComboRchedt: TRichEdit;
  135.     Button2: TButton;
  136.     Button20: TButton;
  137.     PTImageCombo1: TPTImageCombo;
  138.     PTImageCombo2: TPTImageCombo;
  139.     Button13: TButton;
  140.     PTSaveDlg1: TPTSaveDlg;
  141.     OrderTsh: TTabSheet;
  142.     Button21: TButton;
  143.     Button22: TButton;
  144.     OrderBtn: TButton;
  145.     Button23: TButton;
  146.     OrderRchedt: TRichEdit;
  147.     PTTreeTsh: TTabSheet;
  148.     PTTreeView1: TPTTreeView;
  149.     FontBtn: TButton;
  150.     Timer1: TTimer;
  151.     EnableTimerBtn: TSpeedButton;
  152.     CustomDrawTreeRchedt: TRichEdit;
  153.     Button24: TButton;
  154.     Button25: TButton;
  155.     ClickMe1Btn: TButton;
  156.     BoldBtn: TSpeedButton;
  157.     ItalicBtn: TSpeedButton;
  158.     UnderlineBtn: TSpeedButton;
  159.     ScrollBox1: TScrollBox;
  160.     Image3: TImage;
  161.     ScrollBox2: TScrollBox;
  162.     Image1: TImage;
  163.     ResetBtn: TButton;
  164.     PopupMenu1: TPopupMenu;
  165.     LargeIconsMitm1: TMenuItem;
  166.     SmalliconsMItm1: TMenuItem;
  167.     ListMitm1: TMenuItem;
  168.     DetailsMitm1: TMenuItem;
  169.     FontDialog1: TFontDialog;
  170.     FgColorBtn: TButton;
  171.     BkColorBtn: TButton;
  172.     ColorDialog1: TColorDialog;
  173.     BaseBtn: TButton;
  174.     BaseTxt: TLabel;
  175.     Button10: TButton;
  176.     procedure Button1Click(Sender: TObject);
  177.     procedure PaintBox1Paint(Sender: TObject);
  178.     procedure OnNextBtnClick(Sender: TObject);
  179.     procedure OnBackBtnClick(Sender: TObject);
  180.     procedure Button10Click(Sender: TObject);
  181.     procedure FormCreate(Sender: TObject);
  182.     procedure TestOpenDlgBtnClick(Sender: TObject);
  183.     procedure FolderBrowseBtnClick(Sender: TObject);
  184.     procedure PTFolderBrowseDlg1SelChange(aSender: TObject; aNewSel: PItemIDList);
  185.     procedure Button13Click(Sender: TObject);
  186.     procedure OrderBtnClick(Sender: TObject);
  187.     procedure FormDestroy(Sender: TObject);
  188.     procedure EnableTimerBtnClick(Sender: TObject);
  189.     procedure Timer1Timer(Sender: TObject);
  190.     procedure BoldBtnClick(Sender: TObject);
  191.     procedure ItalicBtnClick(Sender: TObject);
  192.     procedure UnderlineBtnClick(Sender: TObject);
  193.     procedure PTTreeView1Deletion(Sender: TObject; Node: TTreeNode);
  194.     procedure ClickMe1BtnClick(Sender: TObject);
  195.     procedure ResetBtnClick(Sender: TObject);
  196.     procedure ViewMitmClick(Sender: TObject);
  197.     procedure FontBtnClick(Sender: TObject);
  198.     procedure FgColorBtnClick(Sender: TObject);
  199.     procedure BkColorBtnClick(Sender: TObject);
  200.     procedure PTTreeView1Change(Sender: TObject; Node: TTreeNode);
  201.     procedure BaseBtnClick(Sender: TObject);
  202.     procedure ToolbarImgMouseMove(Sender: TObject; Shift: TShiftState; X,
  203.       Y: Integer);
  204.     procedure PTTreeView1NodeContextMenu(aSender: TObject;
  205.       aNode: TTreeNode; var aPos: TPoint; var aMenu: TPopupMenu);
  206.     procedure PTTreeView1PTCustomDraw(aSender: TObject; aCD: TPTCustomDraw;
  207.       aNode: TTreeNode);
  208.   private
  209.     procedure LoadRtf( rtf: TRichEdit;  id: Integer );
  210.   protected // -- Palette support -----
  211.     mhPal: HPALETTE;
  212.     mPalStruct: TMaxLogPalette;
  213.     function GetPalette: HPALETTE; override;
  214.     procedure WMPaletteChanged( var aMsg: TWMPaletteChanged ); message WM_PALETTECHANGED;
  215.   protected // -- Custom Draw Tree Page ----
  216.     procedure CDT_DoFontStyle( aNode: TTreeNode;  aDown: Boolean;  aStyle: TFontStyle );
  217.     function  CDT_GetNodeData( aNode: TTreeNode ): TTvData;
  218.     procedure CDT_OnDynamicMenuClick( aSender: TObject );
  219.   public
  220.     { Public declarations }
  221.   end;
  222.  
  223. var
  224.   FrmMain: TFrmMain;
  225.  
  226. implementation
  227. uses ShellApi,
  228.        FExplorer;
  229. {$R *.DFM}
  230.  
  231. {Create a blue-white wash palette with 64 entries}
  232. procedure CreatePaletteStruct( var lp: TMaxLogPalette );
  233. const ENTRIES = 64;
  234.   function PeEntry( r, g, b: Byte ): TPaletteEntry;
  235.   begin
  236.     result.peRed   := r;
  237.     result.peGreen := g;
  238.     result.peBlue  := b;
  239.     result.peFlags := 0;
  240.   end;
  241. var i: Integer;
  242.     tp: TColorRef;
  243.     bt: TColorRef;
  244.  
  245.     tr, tg, tb: Integer;
  246.     br, bg, bb: Integer;
  247. begin
  248.   lp.palVersion := $0300;
  249.   lp.palNumEntries := ENTRIES;
  250.  
  251.   tp := ColorToRGB( clBlue );      bt := ColorToRGB( clWhite );
  252.  
  253.   tr := GetRValue(tp);             br := GetRValue(bt);
  254.   tg := GetGValue(tp);             bg := GetGValue(bt);
  255.   tb := GetBValue(tp);             bb := GetBValue(bt);
  256.  
  257.   for i := 0 to ENTRIES-1 do
  258.     lp.palPalEntry[i] := PeEntry( tr + ((br-tr)*i) div (ENTRIES-1),
  259.                                   tg + ((bg-tg)*i) div (ENTRIES-1),
  260.                                   tb + ((bb-tb)*i) div (ENTRIES-1) );
  261. end; {CreatePaletteStruct}
  262.  
  263.  
  264. {---------------------------------------------------------}
  265.  
  266. constructor TTvData.Create( aFont: TFont;  aColor: TColor );
  267. begin
  268.   mFont := TFont.Create;
  269.   mFont.Assign( aFont );
  270.   mBkColor := aColor;
  271. end;
  272.  
  273. destructor TTvData.Destroy;
  274. begin
  275.   mFont.Free;
  276.   inherited;
  277. end;
  278.  
  279. procedure TTvData.SetFont( aValue: TFont );
  280.   begin mFont.Assign( aValue ); end;
  281.  
  282. {---------------------------------------------------------}
  283.  
  284.  
  285. procedure TFrmMain.Button1Click(Sender: TObject);
  286. begin
  287.   if not Assigned(FrmExplorer) then FrmExplorer := TFrmExplorer.Create(self);
  288.   FrmExplorer.Show;
  289. end;
  290.  
  291.  
  292. { Loads a rich text file from resources into the given rich text control. }
  293. procedure TFrmMain.LoadRtf( rtf: TRichEdit;  id: Integer );
  294. var rs: TResourceStream;
  295. begin
  296.   rs := TResourceStream.CreateFromId( HInstance, id, 'RTF' );
  297.   try rtf.Lines.LoadFromStream( rs ); finally rs.Free; end;
  298. end;
  299.  
  300.  
  301. function TFrmMain.GetPalette: HPALETTE;
  302. begin
  303.   result := mhPal;
  304. end;
  305.  
  306.  
  307. procedure TFrmMain.WMPaletteChanged( var aMsg: TWMPaletteChanged );
  308. begin
  309.   if (aMsg.PalChg <> PaintBox1.Parent.Handle) then
  310.     PaintBox1.Invalidate;
  311.   inherited;
  312. end;
  313.  
  314.  
  315. {$WARNINGS OFF}
  316. procedure Wash( aCanvas: TCanvas;  ahPalette: HPalette;  apPalStruct: PLogPalette;  afActive: Boolean;
  317.                 aRect: TRect;  aFrom, aTo: TColor;  afVertical: Boolean );
  318. type PColorRef=^TColorRef;
  319. var pPalStruct: PMaxLogPalette absolute apPalStruct;
  320.     i: Integer;
  321.     tp: TColorRef;
  322.     bt: TColorRef;
  323.  
  324.     tr, tg, tb: Integer;
  325.     br, bg, bb: Integer;
  326.  
  327.     rc: TRect;
  328.  
  329.     nDivs: Integer;
  330.  
  331.     oldpal: HPALETTE;
  332. begin
  333.   if (ahPalette=0) then
  334.   begin
  335.     tp := ColorToRGB( aFrom );      bt := ColorToRGB( aTo );
  336.     tr := GetRValue(tp);            br := GetRValue(bt);
  337.     tg := GetGValue(tp);            bg := GetGValue(bt);
  338.     tb := GetBValue(tp);            bb := GetBValue(bt);
  339.     if afVertical then
  340.       nDivs := (aRect.bottom - aRect.top) div 2 +1
  341.     else
  342.       nDivs := (aRect.right - aRect.left) div 2 +1;
  343.     rc := aRect;
  344.   end
  345.   else
  346.   begin
  347.     oldpal := SelectPalette( aCanvas.Handle, ahPalette, not afActive );
  348.     RealizePalette( aCanvas.Handle );
  349.     rc := aRect;
  350.     nDivs := 64;
  351.   end;
  352.  
  353.   with aCanvas do
  354.   begin
  355.     for i := 0 to nDivs-1 do
  356.     begin
  357.       if (ahPalette=0) then
  358.         Brush.Color := RGB( tr + ((br-tr)*i) div (nDivs-1),
  359.                             tg + ((bg-tg)*i) div (nDivs-1),
  360.                             tb + ((bb-tb)*i) div (nDivs-1) )
  361.       else
  362.         Brush.Color := $02000000 or PColorRef(@pPalStruct^.palPalEntry[i])^;
  363.       if afVertical then
  364.       begin
  365.         rc.top := ((aRect.bottom - aRect.top)*i) div nDivs;
  366.         rc.bottom := rc.top + (aRect.bottom - aRect.top) div nDivs+1;
  367.       end
  368.       else
  369.       begin
  370.         rc.left := aRect.left + ((aRect.right - aRect.left)*i) div nDivs;
  371.         rc.right := rc.Left + (aRect.right - aRect.left) div nDivs +1;
  372.       end;
  373.       FillRect( rc );
  374.     end;
  375.   end;
  376.  
  377.   if (ahPalette<>0) then
  378.     SelectPalette( aCanvas.Handle, oldpal, TRUE );
  379. end;
  380. {$WARNINGS ON}
  381.  
  382.  
  383. procedure TFrmMain.PaintBox1Paint(Sender: TObject);
  384. begin
  385.   Wash( PaintBox1.Canvas, mhPal, Pointer(@mPalStruct), Active, PaintBox1.ClientRect, clBlue, clWhite, TRUE );
  386. end;
  387.  
  388. procedure TFrmMain.OnNextBtnClick(Sender: TObject);
  389.   begin PageControl1.SelectNextPage(TRUE); end;
  390.  
  391. procedure TFrmMain.OnBackBtnClick(Sender: TObject);
  392.   begin PageControl1.SelectNextPage(FALSE); end;
  393.  
  394. procedure TFrmMain.Button10Click(Sender: TObject);
  395.   const PLASMATECH_URL = 'http://plasmatech.com';
  396.   begin ShellExecute( Handle, nil, PLASMATECH_URL, nil, nil, SW_SHOWNORMAL ); end;
  397.  
  398. procedure TFrmMain.OrderBtnClick(Sender: TObject);
  399.   const ORDER_URL = 'http://order.kagi.com/?J6&S';
  400.   begin ShellExecute( Handle, nil, ORDER_URL, nil, nil, SW_SHOWNORMAL ); end;
  401.  
  402. procedure TFrmMain.FormCreate(Sender: TObject);
  403. var imgl, imgl2: TImageList;
  404.   function IsPalettedDisplay: Bool;
  405.   var dc: HDC;
  406.   begin
  407.     dc := GetDC(0);
  408.     result := ((Windows.GetDeviceCaps(dc, Windows.RASTERCAPS) and RC_PALETTE) <> 0);
  409.     ReleaseDC(0,dc);
  410.   end;
  411.  
  412.   function GetIndexOfExt( ext: String ): Integer;
  413.   var shfi: TSHFileInfo;
  414.   begin
  415.     SHGetFileInfo( PChar(ext),0, shfi, Sizeof(TSHFileInfo), SHGFI_USEFILEATTRIBUTES or SHGFI_ICON );
  416.     result := shfi.iIcon
  417.   end;
  418.  
  419.   procedure AddIt( s: String;  idx, offs: Integer );
  420.   begin
  421.     PTImageCombo1.AddItem( s, idx, offs );
  422.     PTImageCombo2.AddItem( s, idx, offs );
  423.   end;
  424. var s: String;
  425. begin
  426.   Screen.Cursor := crHourglass;
  427.   try
  428.     PageControl1.ActivePage := WelcomeTsh;
  429.  
  430.    // Setup palette
  431.     if IsPalettedDisplay then
  432.     begin
  433.       CreatePaletteStruct( mPalStruct );
  434.       mhPal := Windows.CreatePalette( PLogPalette(@mPalStruct)^ );
  435.     end;
  436.  
  437.    // Load rich text
  438.     LoadRTF( OverviewRchtxt, 101 );
  439.     LoadRTF( ExplorerRchtxt, 102 );
  440.     LoadRTF( FileOpenRchedt, 103 );
  441.     LoadRTF( ShellGetDisplayPathnameRchedt, 104 );
  442.     LoadRTF( FolderBrowseRchedt, 105 );
  443.     LoadRTF( ImageComboRchedt, 106 );
  444.     LoadRTF( OrderRchedt, 107 );
  445.     LoadRTF( CustomDrawTreeRchedt, 108 );
  446.  
  447.    // Setup "Image Combo" Page
  448.     imgl := TImageList.Create(self);
  449.     imgl.ShareImages := TRUE;
  450.     imgl.Handle := ShellGetSystemImageList( ptsizLarge );
  451.     PTImageCombo1.ImageList := imgl;
  452.  
  453.     imgl2 := TImageList.Create(self);
  454.     imgl2.ShareImages := TRUE;
  455.     imgl2.Handle := ShellGetSystemImageList( ptsizSmall );
  456.     PTImageCombo2.ImageList := imgl2;
  457.  
  458.    // Just loading up the image combos with some arbitrary data
  459.     AddIt( 'Text file', GetIndexOfExt('.txt'), 0 );
  460.     AddIt( 'Document',  GetIndexOfExt('.doc'), 1 );
  461.     AddIt( 'HTML file', GetIndexOfExt('.htm'), 1 );
  462.     AddIt( 'Bitmap',    GetIndexOfExt('.bmp'), 2 );
  463.     AddIt( 'GIF image', GetIndexOfExt('.gif'), 1 );
  464.  
  465.     PTImageCombo1.ItemIndex := 0;
  466.     PTImageCombo2.ItemIndex := 1;
  467.  
  468.    // Setup "Custom Draw Tree" page
  469.     PTTreeView1.FullExpand;
  470.  
  471.    // Setup "Splitter Panels" page
  472.     Image3.Picture := PlasmaLogoImg.Picture;
  473.     with Image1.Picture.Bitmap do
  474.     begin
  475.       Width := ToolbarImg.Width;
  476.       Height := ToolbarImg.Height;
  477.       Canvas.Brush.Color := clBtnFace;
  478.       Canvas.BrushCopy( Rect(0,0,Width,Height), ToolbarImg.Picture.Bitmap, Rect(0,0,Width,Height), clFuchsia );
  479.     end;
  480.  
  481.    // Setup "Extra" page
  482.     UppercaseEdt.Text := AnsiUppercase(ParamStr(0));
  483.     GetDisplayEdt.Text := ShellGetDisplayPathname(UppercaseEdt.Text);
  484.  
  485.    //
  486.     s := VersionTxt.Caption;
  487.     if (PTSHELLCONTROLS_VERSION mod 100) <> 0 then
  488.     begin
  489.       s := Format(s, [Format('%.02f',[PTSHELLCONTROLS_VERSION/100])]);
  490.       if s[Length(s)]='0' then SetLength(s, Length(s)-1);
  491.     end
  492.     else
  493.       s := Format(s, [IntToStr(PTSHELLCONTROLS_VERSION div 100)]);
  494.     if (PTSHELLCONTROLS_PATCH > 0) then
  495.       s := s + Char(Ord('a')+PTSHELLCONTROLS_PATCH-1);
  496.     VersionTxt.Caption := s;
  497.     VersionTxt.Autosize := FALSE; VersionTxt.Autosize := TRUE; // Force label to autosize
  498.     VersionTxt.Left := (VersionTxt.Parent.ClientWidth - VersionTxt.Width) div 2;
  499.  
  500.     PTFolderBrowseDlg1.SelectedFolder.Pathname := GetCurrentDir;
  501.  
  502.     BaseTxt.Caption := 'Base is: '+ShellGetFriendlyNameFromIdList( nil, PTFolderBrowseDlg1.BaseFolder.IdList, ptfnNormal );
  503.  
  504.     PTTreeView1.OnPTCustomDraw := PTTreeView1PTCustomDraw;
  505.  
  506.     CopyrightLabel.Caption := Format(CopyrightLabel.Caption, ['⌐']);
  507.     {Delphi 6 puts non ASCII values (Ord>127) in strings in a way that earlier versions can't
  508.      recognize. This run-time assignment avoids the problem for the copyright symbol.}
  509.   finally
  510.     Screen.Cursor := Cursor;
  511.   end;
  512. end;
  513.  
  514. procedure TFrmMain.FormDestroy(Sender: TObject);
  515. begin
  516.   if (mhPal <> 0) then Windows.DeleteObject(mhPal);
  517. end;
  518.  
  519. procedure TFrmMain.TestOpenDlgBtnClick(Sender: TObject);
  520. var i, max: Integer;
  521.     s: String;
  522. begin
  523.   if PTOpenDlg1.Execute then
  524.     if PTOpenDlg1.Files.Count>0 then
  525.     begin
  526.       if PTOpenDlg1.Files.Count>1 then
  527.       begin
  528.         s := 'Multiselect'#13;
  529.         max := PTOpenDlg1.Files.Count-1;
  530.         if max>25 then max:=25;
  531.         for i := 0 to max do
  532.           s := s + PTOpenDlg1.Files[i] + #13;
  533.         if (max < PTOpenDlg1.Files.Count-1) then
  534.           s := s + '...';
  535.         ShowMessage( s );
  536.       end;
  537.       Edit1.Text := PTOpenDlg1.Files[0];
  538.     end;
  539. end;
  540.  
  541. procedure TFrmMain.Button13Click(Sender: TObject);
  542. begin
  543.   PTSaveDlg1.Execute;
  544. end;
  545.  
  546. procedure TFrmMain.FolderBrowseBtnClick(Sender: TObject);
  547. begin
  548.   PTFolderBrowseDlg1.Status := 'This is an example of the TPTFolderBrowseDlg component.';
  549.   if PTFolderBrowseDlg1.Execute then
  550.     ShowMessage( Format( 'You selected:'#13'  Filesystem Name: %s'#13'  Display Name: %s',
  551.                  [ PTFolderBrowseDlg1.SelectedPathname,
  552.                    ShellGetFriendlyNameFromIdList(nil, PTFolderBrowseDlg1.SelectedFolder.IdList, ptfnInFolder)] ) );
  553. end;
  554.  
  555. procedure TFrmMain.PTFolderBrowseDlg1SelChange(aSender: TObject; aNewSel: PItemIDList);
  556. begin
  557.   if Assigned(aNewSel) then
  558.     PTFolderBrowseDlg1.Status := ShellGetPathFromIdList(aNewSel)
  559.   else
  560.     PTFolderBrowseDlg1.Status := '';
  561. end;
  562.  
  563.  
  564. procedure TFrmMain.EnableTimerBtnClick(Sender: TObject);
  565. begin
  566.   EnableTimerBtn.Down := not Timer1.Enabled;
  567.   Timer1.Enabled := EnableTimerBtn.Down;
  568.   PTTreeView1.Invalidate;
  569. end;
  570.  
  571. var _lastpos: Integer = 0;
  572.     _lastposdelta: Integer = +1;
  573.  
  574. procedure TFrmMain.Timer1Timer(Sender: TObject);
  575. begin
  576.   PTTreeView1.InvalidateNode( PTTreeView1.Items[_lastPos], FALSE, TRUE );
  577.   _lastpos := _lastpos + _lastposdelta;
  578.   if (_lastpos > PTTreeView1.Items.Count-1) then
  579.   begin
  580.     _lastpos := PTTreeView1.Items.Count-2;
  581.     _lastposdelta := -1;
  582.   end
  583.   else if (_lastpos < 0) then
  584.   begin
  585.     _lastpos := 1;
  586.     _lastposdelta := +1;
  587.   end;
  588.   PTTreeView1.InvalidateNode( PTTreeView1.Items[_lastPos], FALSE, TRUE );
  589.   PTTreeView1.Update;
  590. end;
  591.  
  592.  
  593. procedure TFrmMain.PTTreeView1PTCustomDraw(aSender: TObject;
  594.   aCD: TPTCustomDraw; aNode: TTreeNode);
  595. begin
  596.   with CDT_GetNodeData(aNode) do
  597.   begin
  598.     aCD.Font := {.}Font;
  599.     if aNode.Selected or aNode.DropTarget then
  600.       if PTTreeView1.Focused then
  601.         aCD.Font.Color := clHighlightText // Use the default item color when it is selected (but still change the font)
  602.       else
  603.         aCD.Font.Color := clBtnText
  604.     else // Don't change the background color for selected items
  605.       aCD.Brush.Color := {.}BkColor;
  606.   end;
  607.  
  608.   if (Timer1.Enabled) then
  609.   begin
  610.     if aNode.AbsoluteIndex = _lastPos then
  611.     begin
  612.       aCD.NoDefaultDrawing := TRUE;
  613.       Wash( aCD.Canvas, mhPal, Pointer(@mPalStruct), Active, aNode.DisplayRect(FALSE), clBlue, clWhite, FALSE );
  614.     end
  615.   end
  616. end;
  617.  
  618. procedure TFrmMain.BoldBtnClick(Sender: TObject);
  619.   begin CDT_DoFontStyle( PTTreeView1.Selected, BoldBtn.Down, fsBold ); end;
  620.  
  621. procedure TFrmMain.ItalicBtnClick(Sender: TObject);
  622.   begin CDT_DoFontStyle( PTTreeView1.Selected, ItalicBtn.Down, fsItalic ); end;
  623.  
  624. procedure TFrmMain.UnderlineBtnClick(Sender: TObject);
  625.   begin CDT_DoFontStyle( PTTreeView1.Selected, UnderlineBtn.Down, fsUnderline ); end;
  626.  
  627. procedure TFrmMain.PTTreeView1Deletion(Sender: TObject; Node: TTreeNode);
  628.   begin if Assigned(Node.Data) then TObject(Node.Data).Free; end;
  629.  
  630. procedure TFrmMain.CDT_DoFontStyle( aNode: TTreeNode;  aDown: Boolean;  aStyle: TFontStyle );
  631. begin
  632.   if not Assigned(aNode) then Exit;
  633.   with CDT_GetNodeData(aNode).Font do
  634.   begin
  635.     if aDown then
  636.       Style := Style + [aStyle]
  637.     else
  638.       Style := Style - [aStyle];
  639.     PTTreeView1.InvalidateNode( aNode, FALSE, TRUE );
  640.     PTTreeView1.Refresh;
  641.   end;
  642. end;
  643.  
  644. function  TFrmMain.CDT_GetNodeData( aNode: TTreeNode ): TTvData;
  645. begin
  646.   if not Assigned(aNode.Data) then
  647.     aNode.Data := TTvData.Create(PTTreeView1.Font, PTTreeView1.Color);
  648.   result := aNode.Data;
  649. end;
  650.  
  651. procedure TFrmMain.CDT_OnDynamicMenuClick( aSender: TObject );
  652.   begin ShowMessage( 'You clicked "' + (aSender as TMenuItem).Caption + '"' ); end;
  653.  
  654. procedure TFrmMain.FontBtnClick(Sender: TObject);
  655. begin
  656.   if Assigned(PTTreeView1.Selected) and Assigned(PTTreeView1.Selected.Data) then
  657.     if FontDialog1.Execute then
  658.     begin
  659.       CDT_GetNodeData(PTTreeView1.Selected).Font := FontDialog1.Font;
  660.       PTTreeView1.InvalidateNode( PTTreeView1.Selected, FALSE, TRUE );
  661.     end;
  662. end;
  663.  
  664. procedure TFrmMain.FgColorBtnClick(Sender: TObject);
  665. begin
  666.   if Assigned(PTTreeView1.Selected) and Assigned(PTTreeView1.Selected.Data) then
  667.     with CDT_GetNodeData( PTTreeView1.Selected ) do
  668.     begin
  669.       ColorDialog1.Color := {.}Font.Color;
  670.       if ColorDialog1.Execute then
  671.         {.}Font.Color := ColorDialog1.Color;
  672.     end;
  673. end;
  674.  
  675. procedure TFrmMain.BkColorBtnClick(Sender: TObject);
  676. begin
  677.   if Assigned(PTTreeView1.Selected) and Assigned(PTTreeView1.Selected.Data) then
  678.     with CDT_GetNodeData( PTTreeView1.Selected ) do
  679.     begin
  680.       ColorDialog1.Color := {.}BkColor;
  681.       if ColorDialog1.Execute then
  682.         {.}BkColor := ColorDialog1.Color;
  683.     end;
  684. end;
  685.  
  686. procedure TFrmMain.ClickMe1BtnClick(Sender: TObject);
  687.   procedure SetItem( aNode: TTreeNode; afs: TFontStyles; aclr, abkclr: TColor );
  688.   begin
  689.     with CDT_GetNodeData(aNode) do
  690.     begin
  691.       Font.Style := afs;
  692.       Font.Color := aclr;
  693.       BkColor := abkclr;
  694.     end;
  695.   end;
  696.  
  697. type TRec = record
  698.        styles: TFontStyles;
  699.        fgclr: TColor;
  700.        bkclr: TColor
  701.      end;
  702.  
  703. const NR: array[0..6] of TRec = (
  704.         (styles: [fsBold];       fgclr: clBlue;           bkclr: clWhite            ), // Fruit
  705.         (styles: [];             fgclr: clYellow;         bkclr: clRed              ), // Apple
  706.         (styles: [];             fgclr: clGreen;          bkclr: clYellow           ), // Pear
  707.         (styles: [fsStrikeout];  fgclr: clWhite;          bkclr: clGreen            ), // Guava
  708.         (styles: [fsBold];       fgclr: clGreen;          bkclr: clWhite            ), // Dogs
  709.         (styles: [fsItalic];     fgclr: clWindowText;     bkclr: clWindow           ), // Shih Tzu
  710.         (styles: [fsItalic];     fgclr: clGray;           bkclr: clWindow           )  // Jack Russel
  711.       );
  712.  
  713. var i: Integer;
  714. begin
  715.   for i := Low(NR) to High(NR) do
  716.     with NR[i] do
  717.       SetItem( PTTreeView1.Items[i], styles, fgclr, bkclr );
  718.   PTTreeView1.Invalidate;
  719. end;
  720.  
  721. procedure TFrmMain.ResetBtnClick(Sender: TObject);
  722. var i: Integer;
  723. begin
  724.   for i := 0 to PTTreeView1.Items.Count-1 do
  725.     with CDT_GetNodeData(PTTreeView1.Items[i]) do
  726.     begin
  727.       Font := PTTreeView1.Font;
  728.       BkColor := PTTreeView1.Color;
  729.     end;
  730.   PTTreeView1.Invalidate;
  731. end;
  732.  
  733. procedure TFrmMain.ViewMitmClick(Sender: TObject);
  734. var i: Integer;
  735. begin
  736.   for i := 0 to PopupMenu1.Items.Count-1 do // Delphi 2 needs this
  737.     PopupMenu1.Items[i].Checked := FALSE;
  738.  
  739.   with (Sender as TMenuItem) do
  740.   begin
  741.     PTShellList1.ViewStyle := TViewStyle( {.}Tag );
  742.     {.}Checked := TRUE;
  743.   end;
  744. end;
  745.  
  746. var gUniqueId: Integer = 0;
  747.  
  748. procedure TFrmMain.PTTreeView1NodeContextMenu(aSender: TObject;
  749.   aNode: TTreeNode; var aPos: TPoint; var aMenu: TPopupMenu);
  750. var m: TPopupMenu;
  751. begin
  752.   aMenu := nil;
  753.  
  754.   m := NewPopupMenu( self, Format('Menu%d',[gUniqueId]), paLeft, FALSE, [
  755.     NewItem(aNode.Text, 0, FALSE, TRUE, CDT_OnDynamicMenuClick, 0, Format('MItem%d',[gUniqueId])) ] );
  756.   Inc( gUniqueId );
  757.  
  758.   try
  759.     with PTTreeView1.ClientToScreen(aPos) do
  760.     begin
  761.       SendCancelMode(nil);
  762.       m.PopupComponent := PTTreeView1;
  763.       m.Popup( x, y );
  764.       Application.ProcessMessages;
  765.         // If you free the menu before messages get processed, which we do, you should call this first. Be aware
  766.         // that by calling ProcessMessages, this event procedure could be re-entered.
  767.     end;
  768.   finally
  769.     m.Free;
  770.   end;
  771. end;
  772.  
  773. procedure TFrmMain.PTTreeView1Change(Sender: TObject; Node: TTreeNode);
  774. var bv, iv, uv: Boolean;
  775. begin
  776.   bv:=FALSE; iv:=FALSE; uv:=FALSE;
  777.   if Assigned(Node) and Assigned(Node.Data) then
  778.     with CDT_GetNodeData(Node) do
  779.     begin
  780.       bv := fsBold in Font.Style;
  781.       iv := fsItalic in Font.Style;
  782.       uv := fsUnderline in Font.Style;
  783.     end;
  784.   BoldBtn.Down := bv;
  785.   ItalicBtn.Down := iv;
  786.   UnderlineBtn.Down := uv;
  787. end;
  788.  
  789. procedure TFrmMain.BaseBtnClick(Sender: TObject);
  790. var f: TPTFolderBrowseDlg;
  791. begin
  792.   f := TPTFolderBrowseDlg.Create( self );
  793.   try
  794.     f.Status := 'Select a folder to act as base folder.';
  795.     f.SelectedFolder := PTFolderBrowseDlg1.BaseFolder;
  796.     if f.Execute then
  797.     begin
  798.       PTFolderBrowseDlg1.BaseFolder := f.SelectedFolder;
  799.       BaseTxt.Caption := 'Base is: '+ShellGetFriendlyNameFromIdList( nil, f.SelectedFolder.IdList, ptfnNormal );
  800.       PTFolderBrowseDlg1.SelectedFolder := f.SelectedFolder;
  801.     end;
  802.   finally
  803.     f.Free;
  804.   end;
  805. end;
  806.  
  807. procedure TFrmMain.ToolbarImgMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
  808. const ComponentNames: array[0..13] of String = (
  809.         'TPTShellTree'#13#13'Enhanced Explorer tree view.',
  810.         'TPTShellList'#13#13'Enhanced Explorer list view.',
  811.         'TPTShellCombo'#13#13'Explorer combo box.',
  812.         'TPTOpenDlg'#13#13'Powerful replacement for TOpenDlg.',
  813.         'TPTSaveDlg'#13#13'Powerful replacement for TSaveDlg.',
  814.         'TPTFolderBrowseDlg'#13#13'Powerful replacement for SHBrowseForFolder.',
  815.         'TPTFrame'#13#13'Non-windowed frame control with 11 frame styles.',
  816.         'TPTGroup'#13#13'Windowed TPanel replacement with 11 frame styles.',
  817.         'TPTSplitter'#13#13'Powerful and simple splitter control.',
  818.         'TPTImageCombo'#13#13'Combo box with image and indent'#13'level per item.',
  819.         'TPTSysFolderDlg'#13#13'Encapsulation of the system''s'#13'built-in SHBrowseForFolder function.',
  820.         'TPTCombobox'#13#13'Combo box control with events for'#13'OnDeleteItem, OnCloseUp, OnSelEndOk and OnSelEndCancel.',
  821.         'TPTTreeView'#13#13'Enhanced tree view control with Internet Explorer 3/4 features.',
  822.         'TPTListView'#13#13'Enhanced list view control with Internet Explorer 3/4 features.'
  823.       );
  824. var item: Integer;
  825. begin
  826.   item := (x-8) div 28;
  827.   if (item < Low(ComponentNames)) or (item > High(ComponentNames)) then
  828.   begin
  829.     Application.CancelHint;
  830.     ToolbarImg.Hint := '';
  831.   end
  832.   else
  833.   begin
  834.     if ToolbarImg.Hint <> ComponentNames[item] then
  835.     begin
  836.       Application.CancelHint;
  837.       ToolbarImg.Hint := ComponentNames[item];
  838.     end;
  839.   end;
  840. end;
  841.  
  842.  
  843. end.
  844.  
  845.